home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue27 / archaeop / DinoSource / CommonStuff.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-09-17  |  6.5 KB  |  179 lines
  1. unit CommonStuff;
  2.  
  3. interface
  4.  
  5. uses
  6.   Menus, ComCtrls, Classes, Forms, Registry, SysUtils;
  7.  
  8. type
  9.   TIvoryHacker = class(TObject)
  10.   public
  11.     FTabControl: TTabControl; //Component palette
  12.     FPalettePopup: TPopupMenu; //Palette popup menu
  13.     FOptions: TMenuItem; //Archaeopteryx options menu item
  14.     Ini: TRegIniFile; //Used to save and restore options in registry
  15.     procedure DoAbout(Sender: TObject); //Shows About box
  16.     procedure AddOptionsItem; //Ensures Options item exists
  17.     constructor Create;
  18.     destructor Destroy; override;
  19.   end;
  20.  
  21. var
  22.   Stuff: TIvoryHacker;
  23.  
  24. //Locate a requested component object
  25. function GetComponent(Owner: TComponent; const Name, Error: String): TComponent;
  26.  
  27. //Warn user if an event that we chain is already chained
  28. procedure TestChainedEventHandler(OldHandler, NewHandler: Pointer);
  29.  
  30. resourcestring
  31.   SSetupError = 'An error occurred in customising the IDE';
  32.   SGenericError = 'Cannot find requested component: ';
  33.   SAbout = '&About Archaeopteryx...';
  34.  
  35. const
  36.   SRegSection = 'Archaeopteryx';
  37.  
  38. implementation
  39.  
  40. uses
  41.   Dialogs, ExtCtrls, Windows;
  42.  
  43. {$R Bitmap.Res}
  44.  
  45. resourcestring
  46.   SOptions = '&Options';
  47.   SAboutCaption = 'About Archaeopteryx';
  48.   SAboutMsg = 'Archaeopteryx.'#13#13 +
  49.     'Archaeopteryx (ahr-kee-ahp-tur-iks) is a prehistoric piece of' +
  50.     'software, dug out of the ground and restored by Oblong, ⌐ 1997.'#13#13 +
  51.     'This is freeware by the way - everyone''s doin'' it!'#13#13 +
  52.     'The source code for this package accompanies an article ' +
  53.     'on IDE customising in The Delphi Magazine in November, 1997'#13#13;
  54.   SChainingWarning = 'IMPORTANT INFORMATION!!!'#13#13+
  55.     'The Archaeopteryx package has modified part of Delphi''s internals ' +
  56.     'in order to operate effectively. However it appears that another ' +
  57.     'add-in package has also done a similar POTENTIALLY conflicting ' +
  58.     'modification.'#13#13 +
  59.     'In order to avoid the POSSIBLE problems when removing your ' +
  60.     'add-in packages, ensure Archaeopteryx is uninstalled before ' +
  61.     'any of your previously installed packages.'#13#13 +
  62.     'Alternatively, uninstall Archaeopteryx now, followed by all ' +
  63.     'the other add-in packages and then re-install Archaeopteryx ' +
  64.     'first, followed by all the others'#13#13'Thank you';
  65.  
  66. const
  67.   SPaletteMenu = 'PaletteMenu'; //Component palette popup menu
  68.   STabControl = 'TabControl'; //Component palette
  69.   SIconName = 'Archaeopteryx'; //My Archaeopteryx icon resource
  70.   SImage = 'Image'; //Name of picture component on a message dialog
  71.   //Registry strings
  72.   SRegPath = 'Software\Oblong\';
  73.   SRegWarning = 'Warning';
  74.  
  75. function GetComponent(Owner: TComponent; const Name, Error: String): TComponent;
  76. begin
  77.   Result := Owner.FindComponent(Name);
  78.   if not Assigned(Result) then
  79.     raise Exception.Create(Error);
  80. end;
  81.  
  82. procedure TestChainedEventHandler(OldHandler, NewHandler: Pointer);
  83. begin
  84.   //If the original (as designed) handler and
  85.   //the current handler of an event are not the same,
  86.   //then report the error to the user the first time
  87.   if (OldHandler <> NewHandler) and
  88.      Stuff.Ini.ReadBool(SRegSection, SRegWarning, True) then
  89.   begin
  90.     MessageDlg(SChainingWarning, mtWarning, [mbOk], 0);
  91.     //Set registry flag so the error is not reported again
  92.     Stuff.Ini.WriteBool(SRegSection, SRegWarning, False)
  93.   end
  94. end;
  95.  
  96. constructor TIvoryHacker.Create;
  97. begin
  98.   inherited Create;
  99.   //For registry access
  100.   Ini := TRegIniFile.Create(SRegPath);
  101.   //Locate various IDE components
  102.   FTabControl := GetComponent(Application.MainForm, STabControl, SGenericError + STabControl) as TTabControl;
  103.   FPalettePopup := GetComponent(Application.MainForm, SPaletteMenu, SGenericError + SPaletteMenu) as TPopupMenu;
  104. end;
  105.  
  106. destructor TIvoryHacker.Destroy;
  107. begin
  108.   //Get rid of registry object
  109.   Ini.Free;
  110.   //If someone made an options menu, then get rid of it
  111.   FOptions.Free;
  112.   inherited Destroy
  113. end;
  114.  
  115. procedure TIvoryHacker.DoAbout(Sender: TObject);
  116.  
  117. //Code to extract program version an file
  118.   //version from the current binary file
  119.   function VersionNumber: String;
  120.   var
  121.     VerInfo: Pointer;
  122.     Len, BufSize: Integer;
  123.     Dest: PChar;
  124.     DestCodeInfo: ^LongRec;
  125.     LangCharSet: String;
  126.     FileName: array[0..Max_Path] of Char;
  127.   begin
  128.     Result := '';
  129.     //Find current binary file name
  130.     GetModuleFileName(HInstance, FileName, Max_Path);
  131.     //How big is version info?
  132.     BufSize := GetFileVersionInfoSize(FileName, Len);
  133.     if BufSize > 0 then
  134.     begin
  135.       //Reserve sufficient memory
  136.       GetMem(VerInfo, BufSize);
  137.       try
  138.         //Get version information
  139.         if GetFileVersionInfo(FileName, 0, BufSize, VerInfo) then
  140.         begin
  141.           //Get translation table
  142.           if VerQueryValue(VerInfo, '\VarFileInfo\Translation', Pointer(DestCodeInfo), Len) and
  143.              (Len >= 4) then { Translation table exists}
  144.             LangCharSet := Format('\StringFileInfo\%.4x%.4x\', [DestCodeInfo^.Lo, DestCodeInfo^.Hi]);
  145.           //Get ver. info. value via translation table
  146.           if VerQueryValue(VerInfo, PChar(LangCharSet + 'ProductVersion'), Pointer(Dest), Len) then
  147.             AppendStr(Result, 'Version ' + StrPas(Dest));
  148.           //Get ver. info. value via translation table
  149.           if VerQueryValue(VerInfo, PChar(LangCharSet + 'FileVersion'), Pointer(Dest), Len) then
  150.             AppendStr(Result, ' (Build ' + StrPas(Dest) + ')');
  151.         end
  152.       finally
  153.         //Free sufficient memory
  154.         FreeMem(VerInfo, BufSize);
  155.       end
  156.     end
  157.   end;
  158.  
  159. begin
  160.   //Would normally use MessageDlg, but I
  161.   //want to customise the icon, so use
  162.   //the more primitive CreateMessageDialog
  163.   with CreateMessageDialog(SAboutMsg + VersionNumber, mtInformation, [mbOk]) do
  164.     try
  165.       (FindComponent(SImage) as TImage).Picture.Icon.Handle :=
  166.         LoadIcon(HInstance, PChar(SIconName));
  167.       Caption := SAboutCaption;
  168.       ShowModal;
  169.     finally
  170.       Free
  171.     end;
  172. end;
  173.  
  174. procedure TIvoryHacker.AddOptionsItem;
  175. begin
  176.   //If another unit needs to add options items,
  177.   //they call this to add the main Options sub-menu
  178.   //just above the last menu item (Properties)
  179.   if not Assigned(FOptions) then
  180.   begin
  181.     FOptions := NewItem(SOptions, 0, False, True, nil, 0, '');
  182.     FPalettePopup.Items.Add(FOptions);
  183.     FOptions.MenuIndex := FPalettePopup.Items.Count - 1;
  184.   end;
  185. end;
  186.  
  187. initialization
  188.   try
  189.     Stuff := TIvoryHacker.Create
  190.   except
  191.     on E: Exception do
  192.       ShowMessage(SSetupError + ': ' + E.Message)
  193.   end
  194. finalization
  195.   Stuff.Free
  196. end.
  197.